The Atari Compendium/The Atari Compendium (Toad Computers) (1994).iso/files/prgtools/langs/pcl-src.zoo/dfun.lsp

Lisp/Scheme | 1992-07-09 | 33.2 KB | 904 lines

;;; -*- Mode:LISP; Package:PCL; Base:10; Syntax:Common-Lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
;;; All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted.  Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;;
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;;
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;;   CommonLoops Coordinator
;;;   Xerox PARC
;;;   3333 Coyote Hill Rd.
;;;   Palo Alto, CA 94304
;;; (or send Arpanet mail to [e-mail])
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;

(in-package 'pcl)

#|

This implementation of method lookup was redone in early August of 89.

It has the following properties:

 - It's modularity makes it easy to modify the actual caching algorithm.
   The caching algorithm is almost completely separated into the files
   cache.lisp and dlap.lisp.  This file just contains the various uses
   of it. There will be more tuning as we get more results from Luis'
   measurements of caching behavior.

 - The metacircularity issues have been dealt with properly.  All of
   PCL now grounds out properly.  Moreover, it is now possible to have
   metaobject classes which are themselves not instances of standard
   metaobject classes.

** Modularity of the code **

The actual caching algorithm is isolated in a modest number of functions.
The code which generates cache lookup code is all found in cache.lisp and
dlap.lisp.  Certain non-wrapper-caching special cases are in this file.


** Handling the metacircularity **

In CLOS, method lookup is the potential source of infinite metacircular
regress.  The metaobject protocol specification gives us wide flexibility
in how to address this problem.  PCL uses a technique which handles the
problem not only for the metacircular language described in Chapter 3, but
also for the PCL protocol which includes additional generic functions
which control more aspects of the CLOS implementation.

The source of the metacircular regress can be seen in a number of ways.
One is that the specified method lookup protocol must, as part of doing
the method lookup (or at least the cache miss case), itself call generic
functions.  It is easy to see that if the method lookup for a generic
function ends up calling that same generic function there can be trouble.

Fortunately, there is an easy solution at hand.  The solution is based on
the restriction that portable code cannot change the class of a specified
metaobject.  This restriction implies that for specified generic functions,
the method lookup protocol they follow is fixed.

More precisely, for such specified generic functions, most generic functions
that are called during their own method lookup will not run portable methods.
This allows the implementation to usurp the actual generic function call in
this case.  In short, method lookup of a standard generic function, in the
case where the only applicable methods are themselves standard doesn't
have to do any method lookup to implement itself.

And so, we are saved.

|#



;An alist in which each entry is of the form :
;  (<generator> . (<subentry> ...))
;Each subentry is of the form:
;  (<args> <constructor> <system>)
(defvar *dfun-constructors* ())

;If this is NIL, then the whole mechanism
;for caching dfun constructors is turned
;off.  The only time that makes sense is
;when debugging LAP code.
(defvar *enable-dfun-constructor-caching* t)

(defun show-dfun-constructors ()
  (format t "~&DFUN constructor caching is ~A."
      (if *enable-dfun-constructor-caching*
          "enabled" "disabled"))
  (dolist (generator-entry *dfun-constructors*)
    (dolist (args-entry (cdr generator-entry))
      (format t "~&~S ~S"
          (cons (car generator-entry) (caar args-entry))
          (caddr args-entry)))))


(declaim (ftype (function (T &rest T) real-function) get-dfun-constructor))
(defun get-dfun-constructor (generator &rest args)
  (let* ((generator-entry (assq generator *dfun-constructors*))
     (args-entry (assoc args (cdr generator-entry) :test #'equal)))
    (if (null *enable-dfun-constructor-caching*)
    (apply-function (symbol-function generator) args)
    (or (cadr args-entry)
        (let ((new (apply-function (symbol-function generator) args)))
          (if generator-entry
          (push (list (copy-list args) new nil) (cdr generator-entry))
          (push (list generator (list (copy-list args) new nil)) *dfun-constructors*))
          new)))))

(defun load-precompiled-dfun-constructor (generator args system constructor)
  (let* ((generator-entry (assq generator *dfun-constructors*))
     (args-entry (assoc args (cdr generator-entry) :test #'equal)))
    (unless args-entry
      (if generator-entry
      (push (list args constructor system) (cdr generator-entry))
      (push (list generator (list args constructor system)) *dfun-constructors*)))))

(defmacro precompile-dfun-constructors (&optional system)
  #+excl (declare (ignore system))
  #+excl ()
  #-excl
  (let ((*precompiling-lap* t))
    `(progn
       ,@(gathering1 (collecting)
       (dolist (generator-entry *dfun-constructors*)
         (dolist (args-entry (cdr generator-entry))
           (when (or (null (caddr args-entry))
             (eq (caddr args-entry) system))
         (when system (setf (caddr args-entry) system))
         (multiple-value-bind (closure-variables arguments
                             iregs vregs fvregs tregs lap)
             (apply-function (symbol-function (car generator-entry))
                                     (car args-entry))
           (gather1
             (make-top-level-form `(precompile-dfun-constructor
                        ,(car generator-entry))
                      '(load)
               `(load-precompiled-dfun-constructor
              ',(car generator-entry)
              ',(car args-entry)
              ',system
              (precompile-lap-closure-generator ,closure-variables
                                ,arguments
                                ,iregs
                                ,vregs
                                                ,fvregs
                                ,tregs
                                ,lap))))))))))))


;;;
;;; When all the methods of a generic function are automatically generated
;;; reader or writer methods a number of special optimizations are possible.
;;; These are important because of the large number of generic functions of
;;; this type.
;;;
;;; There are a number of cases:
;;;
;;;   ONE-CLASS-ACCESSOR
;;;     In this case, the accessor generic function has only been called
;;;     with one class of argument.  There is no cache vector, the wrapper
;;;     of the one class, and the slot index are stored directly as closure
;;;     variables of the discriminating function.  This case can convert to
;;;     either of the next kind.
;;;
;;;   TWO-CLASS-ACCESSOR
;;;     Like above, but two classes.  This is common enough to do specially.
;;;     There is no cache vector.  The two classes are stored a separate
;;;     closure variables.
;;;
;;;   ONE-INDEX-ACCESSOR
;;;     In this case, the accessor generic function has seen more than one
;;;     class of argument, but the index of the slot is the same for all
;;;     the classes that have been seen.  A cache vector is used to store
;;;     the wrappers that have been seen, the slot index is stored directly
;;;     as a closure variable of the discriminating function.  This case
;;;     can convert to the next kind.
;;;
;;;   N-N-ACCESSOR
;;;     This is the most general case.  In this case, the accessor generic
;;;     function has seen more than one class of argument and more than one
;;;     slot index.  A cache vector stores the wrappers and corresponding
;;;     slot indexes.  Because each cache line is more than one element
;;;     long, a cache lock count is used.
;;;
(defstruct (dfun-info
         (:constructor nil)
         (:print-function print-dfun-info))
  (cache nil))

(defun print-dfun-info (dfun-info stream depth)
  (declare (ignore depth) (stream stream))
  (printing-random-thing (dfun-info stream)
    (format stream "~A" (type-of dfun-info))))

(defstruct (no-methods
         (:constructor no-methods-dfun-info ())
         (:include dfun-info)))

(defstruct (initial-dispatch
         (:constructor initial-dispatch-dfun-info ())
         (:include dfun-info)))

(defstruct (dispatch
         (:constructor dispatch-dfun-info ())
         (:include dfun-info)))

(defstruct (default-method-only
         (:constructor default-method-only-dfun-info ())
         (:include dfun-info)))

;without caching:
;  dispatch one-class two-class default-method-only

;with caching:
;  one-index n-n checking caching

;accessor:
;  one-class two-class one-index n-n
(defstruct (accessor-dfun-info
         (:constructor nil)
         (:include dfun-info))
  accessor-type) ; (member reader writer)

(defmacro dfun-info-accessor-type (di)
  `(accessor-dfun-info-accessor-type ,di))

(defstruct (one-index-dfun-info
         (:constructor nil)
         (:include accessor-dfun-info))
  index)

(defmacro dfun-info-index (di)
  `(one-index-dfun-info-index ,di))

(defstruct (n-n
         (:constructor n-n-dfun-info (accessor-type cache))
         (:include accessor-dfun-info)))

(defstruct (one-class
         (:constructor one-class-dfun-info (accessor-type index wrapper0))
         (:include one-index-dfun-info))
  wrapper0)

(defmacro dfun-info-wrapper0 (di)
  `(one-class-wrapper0 ,di))

(defstruct (two-class
         (:constructor two-class-dfun-info (accessor-type index wrapper0 wrapper1))
         (:include one-class))
  wrapper1)

(defmacro dfun-info-wrapper1 (di)
  `(two-class-wrapper1 ,di))

(defstruct (one-index
         (:constructor one-index-dfun-info
               (accessor-type index cache))
         (:include one-index-dfun-info)))

(defstruct (checking
         (:constructor checking-dfun-info (function cache))
         (:include dfun-info))
  function)

(defmacro dfun-info-function (di)
  `(checking-function ,di))

(defstruct (caching
         (:constructor caching-dfun-info (cache))
         (:include dfun-info)))

(defstruct (constant-value
         (:constructor constant-value-dfun-info (cache))
         (:include dfun-info)))

(defmacro dfun-update (generic-function function &rest args)
  `(multiple-value-bind (dfun cache info)
       (funcall-function ,function ,generic-function ,@args)
     (update-dfun ,generic-function dfun cache info)))

(defun accessor-miss-function (gf dfun-info)
  (ecase (dfun-info-accessor-type dfun-info)
    (reader
      #'(lambda (arg)
       (declare (pcl-fast-call))
       (accessor-miss gf nil arg dfun-info)))
    (writer
     #'(lambda (new arg)
     (declare (pcl-fast-call))
     (accessor-miss gf new arg dfun-info)))))


(declaim (ftype (function (T T T T) (values function null T))
        make-one-class-accessor-dfun))
(declaim (ftype (function (T T T T T) (values function null T))
        make-two-class-accessor-dfun))
(declaim (ftype (function (T T T &optional T) (values function cache T))
        make-one-index-accessor-dfun))
(declaim (ftype (function (T T T T) (values function cache T))
        make-final-one-index-accessor-dfun))
(declaim (ftype (function (T T &optional T) (values function cache T))
        make-n-n-accessor-dfun))
(declaim (ftype (function (T T T) (values function cache T))
        make-final-n-n-accessor-dfun))
(declaim (ftype (function (T T &optional T) (values function (or cache null) T))
        make-checking-dfun))
(declaim (ftype (function (T T T T) (values function (or cache null) T))
        make-final-checking-dfun))
(declaim (ftype (function (T &optional T) (values function (or cache null) T))
        make-caching-dfun))
(declaim (ftype (function (T T T) (values function (or cache null) T))
        make-final-caching-dfun))
(declaim (ftype (function (T &optional T) (values function cache T))
        make-constant-value-dfun))
(declaim (ftype (function (T T T) (values function cache T))
        make-final-constant-value-dfun))
(declaim (ftype (function (T) (values function null T))
        make-dispatch-dfun
        make-final-dispatch-dfun))
(declaim (ftype (function (T &optional T) (values function (or cache null) T))
        make-final-dfun-internal))

(declaim (ftype (function (T) boolean)
        use-caching-dfun-p
        use-dispatch-dfun-p))

;;;
;;; ONE-CLASS-ACCESSOR
;;;
(declaim (ftype (function (T T T T) (values function null T))
        make-one-class-accessor-dfun))
(defun make-one-class-accessor-dfun (gf type wrapper index)
  (let ((emit (if (eq type 'reader) 'emit-one-class-reader 'emit-one-class-writer))
    (dfun-info (one-class-dfun-info type index wrapper)))
    (values
     (funcall (get-dfun-constructor emit (consp index))
          wrapper index
          (accessor-miss-function gf dfun-info))
     nil
     dfun-info)))

;;;
;;; TWO-CLASS-ACCESSOR
;;;
(declaim (ftype (function (T T T T T) (values function null T))
        make-two-class-accessor-dfun))
(defun make-two-class-accessor-dfun (gf type w0 w1 index)
  (let ((emit (if (eq type 'reader) 'emit-two-class-reader 'emit-two-class-writer))
    (dfun-info (two-class-dfun-info type index w0 w1)))
    (values
     (funcall (get-dfun-constructor emit (consp index))
          w0 w1 index
          (accessor-miss-function gf dfun-info))
     nil
     dfun-info)))

;;;
;;; std accessors same index dfun
;;;
(declaim (ftype (function (T T T &optional T) (values function cache T))
        make-one-index-accessor-dfun))
(defun make-one-index-accessor-dfun (gf type index &optional cache)
  (let* ((emit (if (eq type 'reader) 'emit-one-index-readers 'emit-one-index-writers))
     (cache (or cache (get-cache 1 nil #'one-index-limit-fn 4)))
     (dfun-info (one-index-dfun-info type index cache)))
    (declare (type cache cache))
    (values
     (funcall (get-dfun-constructor emit (consp index))
          (cache-field cache) (cache-vector cache)
          (cache-mask cache) (cache-size cache)
          index
          (accessor-miss-function gf dfun-info))
     cache
     dfun-info)))

(declaim (ftype (function (T T T T) (values function cache T))
        make-final-one-index-accessor-dfun))
(defun make-final-one-index-accessor-dfun (gf type index table)
  (let ((cache (fill-dfun-cache table nil 1 #'one-index-limit-fn)))
    (make-one-index-accessor-dfun gf type index cache)))

(defun one-index-limit-fn (nlines)
  (default-limit-fn nlines))


(declaim (ftype (function (T T &optional T) (values function cache T))
        make-n-n-accessor-dfun))
(defun make-n-n-accessor-dfun (gf type &optional cache)
  (let* ((emit (if (eq type 'reader) 'emit-n-n-readers 'emit-n-n-writers))
     (cache (or cache (get-cache 1 t #'n-n-accessors-limit-fn 2)))
     (dfun-info (n-n-dfun-info type cache)))
    (declare (type cache cache))
    (values
     (funcall (get-dfun-constructor emit)
          (cache-field cache) (cache-vector cache)
          (cache-mask cache) (cache-size cache)
          (accessor-miss-function gf dfun-info))
     cache
     dfun-info)))

(declaim (ftype (function (T T T) (values function cache T))
        make-final-n-n-accessor-dfun))
(defun make-final-n-n-accessor-dfun (gf type table)
  (let ((cache (fill-dfun-cache table t 1 #'n-n-accessors-limit-fn)))
    (make-n-n-accessor-dfun gf type cache)))

(defun n-n-accessors-limit-fn (nlines)
  (default-limit-fn nlines))

(defun fill-dfun-cache (table valuep nkeys limit-fn &optional cache)
  (let ((cache
          (or cache
              (get-cache
                 nkeys valuep limit-fn
         (the index (+ (the index (hash-table-count table)) 3))))))
    (maphash #'(lambda (classes value)
         (setq cache (fill-cache cache
                     (class-wrapper classes)
                     value
                     t)))
         table)
    cache))


;;;
;;;
;;;


(defun make-checking-dfun (generic-function function &optional cache)
  (unless cache
    (when (some #'(lambda (method)
            (method-closure-generator method))
        (generic-function-methods generic-function))
      (return-from make-checking-dfun (make-caching-dfun generic-function)))
    (when (use-dispatch-dfun-p generic-function)
      (return-from make-checking-dfun (make-dispatch-dfun generic-function))))
  (let* ((arg-info (gf-arg-info generic-function))
     (metatypes (arg-info-metatypes arg-info))
     (applyp (arg-info-applyp arg-info))
     (nkeys (arg-info-nkeys arg-info)))
    (declare (type boolean applyp) (type index nkeys))
    (if (every #'(lambda (mt) (eq mt 't)) metatypes)
    (values function nil (default-method-only-dfun-info))
    (let* ((cache (or cache (get-cache nkeys nil #'checking-limit-fn 2)))
           (dfun-info (checking-dfun-info function cache)))
      (values
       (funcall (get-dfun-constructor 'emit-checking metatypes applyp)
            (cache-field cache) (cache-vector cache)
            (cache-mask cache) (cache-size cache)
            function
            #'(lambda (&rest args)
            (declare (pcl-fast-call))
            (checking-miss generic-function args dfun-info)))
       cache
       dfun-info)))))

(defun make-final-checking-dfun (generic-function function
                          classes-list new-class)
  (let ((metatypes (arg-info-metatypes (gf-arg-info generic-function))))
    (if (every #'(lambda (mt) (eq mt 't)) metatypes)
    (values function nil (default-method-only-dfun-info))
    (let ((cache (make-final-ordinary-dfun-internal
              generic-function nil #'checking-limit-fn
              classes-list new-class)))
      (make-checking-dfun generic-function function cache)))))

(defun checking-limit-fn (nlines)
  (default-limit-fn nlines))


;;;
;;;
;;;
(defun make-caching-dfun (generic-function &optional cache)
  (unless cache
    (when (use-constant-value-dfun-p generic-function)
      (return-from make-caching-dfun (make-constant-value-dfun generic-function)))
    (when (use-dispatch-dfun-p generic-function)
      (return-from make-caching-dfun (make-dispatch-dfun generic-function))))
  (let* ((arg-info (gf-arg-info generic-function))
     (metatypes (arg-info-metatypes arg-info))
     (applyp (arg-info-applyp arg-info))
     (nkeys (arg-info-nkeys arg-info))
     (cache (or cache (get-cache nkeys t #'caching-limit-fn 2)))
     (dfun-info (caching-dfun-info cache)))
    (declare (type boolean applyp) (type index nkeys))
    (values
     (funcall (get-dfun-constructor 'emit-caching metatypes applyp)
          (cache-field cache) (cache-vector cache)
          (cache-mask cache) (cache-size cache)
          #'(lambda (&rest args)
          (declare (pcl-fast-call))
          (caching-miss generic-function args dfun-info)))
     cache
     dfun-info)))

(defun make-final-caching-dfun (generic-function classes-list new-class)
  (let ((cache (make-final-ordinary-dfun-internal
        generic-function t #'caching-limit-fn
        classes-list new-class)))
    (make-caching-dfun generic-function cache)))

(defun caching-limit-fn (nlines)
  (default-limit-fn nlines))

(defun use-constant-value-dfun-p (gf)
  (let ((methods (generic-function-methods gf))
    (default '(unknown)))
    (declare (type list methods))
    (and (null (arg-info-applyp (gf-arg-info gf)))
     (compute-applicable-methods-emf-std-p gf)
     (< 1 (length methods))
     (some #'(lambda (method)
           (every #'(lambda (specl) (eq specl *the-class-t*))
              (method-specializers method)))
           methods)
     (notany #'(lambda (method)
             (or (some #'eql-specializer-p
                   (method-specializers method))
             (eq (plist-value method :constant-value default)
                 default)))
        methods))))

(defun make-constant-value-dfun (generic-function &optional cache)
  (let* ((arg-info (gf-arg-info generic-function))
     (metatypes (arg-info-metatypes arg-info))
     (nkeys (arg-info-nkeys arg-info))
     (cache (or cache (get-cache nkeys t #'caching-limit-fn 2)))
     (dfun-info (constant-value-dfun-info cache)))
    (values
     (funcall (get-dfun-constructor 'emit-constant-value metatypes)
          (cache-field cache) (cache-vector cache)
          (cache-mask cache) (cache-size cache)
          #'(lambda (&rest args)
          (declare (pcl-fast-call))
          (constant-value-miss generic-function args dfun-info)))
     cache
     dfun-info)))

(defun make-final-constant-value-dfun (generic-function classes-list new-class)
  (let ((cache (make-final-ordinary-dfun-internal
        generic-function :constant-value #'caching-limit-fn
        classes-list new-class)))
    (make-constant-value-dfun generic-function cache)))

(defun make-final-ordinary-dfun-internal (generic-function valuep limit-fn
                      classes-list new-class)
  (let* ((arg-info (gf-arg-info generic-function))
     (nkeys (arg-info-nkeys arg-info))
     (new-class (and new-class
             (equal (type-of (gf-dfun-info generic-function))
                (cond ((eq valuep t) 'caching)
                      ((eq valuep :constant-value) 'constant-value)
                      ((null valuep) 'checking)))
             new-class))
     (cache (if new-class
            (copy-cache (gf-dfun-cache generic-function))
            (get-cache nkeys (not (null valuep)) limit-fn 4))))
      (declare (type index nkeys))
      (make-emf-cache generic-function valuep cache classes-list new-class)))

(defun use-caching-dfun-p (gf)
  (some #'method-function-for-caching-p (generic-function-methods gf)))

(defun use-dispatch-dfun-p (gf)
  (unless (use-caching-dfun-p gf)
    (let* ((methods (generic-function-methods gf))
       (arg-info (gf-arg-info gf))
       (mt (arg-info-metatypes arg-info))
       (nreq (length mt)))
      (declare (type list methods mt) (type index nreq))
      ;;Is there a position at which every specializer is eql or non-standard?
      (dotimes (i nreq nil)
    (when (not (eq 't (nth i mt)))
      (let ((some-std-class-specl-p nil))
        (dolist (method methods)
          (let ((specl (nth i (method-specializers method))))
        (when (and (not (eql-specializer-p specl))
                           (class-standard-p (specializer-class specl)))
          (setq some-std-class-specl-p t))))
        (unless some-std-class-specl-p
          (return-from use-dispatch-dfun-p t))))))))

(defvar *lazy-dispatch-dfun-compute-p* t)
(defvar *lazy-dfun-compute-p* nil)

(defun make-dispatch-dfun (gf)
  (values (get-dispatch-function gf) nil (dispatch-dfun-info)))

(defun make-final-dispatch-dfun (gf)
  (if *lazy-dispatch-dfun-compute-p*
      (values (let ((*lazy-dfun-compute-p* t))
        (make-initial-dfun gf))
          nil (initial-dispatch-dfun-info))
      (make-dispatch-dfun gf)))

(defun before-precompile-random-code-segments ()
  (dolist (gf (gfs-of-type '(dispatch initial-dispatch)))
    (dfun-update gf #'make-dispatch-dfun)))

(defvar *dfun-miss-gfs-on-stack* ())

(defmacro dfun-miss ((gf args wrappers invalidp nfunction
              &optional type index caching-p applicable)
             &body body)
  (unless applicable (setq applicable (gensym)))
  `(multiple-value-bind (,wrappers ,invalidp ,nfunction ,applicable
                   ,@(when type `(,type ,index)))
       (cache-miss-values ,gf ,args ',(cond (type 'accessor)
                        (caching-p 'caching)
                        (t 'checking)))
     (declare (type boolean ,invalidp))
     (when (and ,applicable (not (memq ,gf *dfun-miss-gfs-on-stack*)))
       (let ((*dfun-miss-gfs-on-stack* (cons ,gf *dfun-miss-gfs-on-stack*)))
     ,@body))
     (method-function-apply ,nfunction ,args)))

;;;
;;; The dynamically adaptive method lookup algorithm is implemented is
;;; implemented as a kind of state machine.  The kinds of discriminating
;;; function is the state, the various kinds of reasons for a cache miss
;;; are the state transitions.
;;;
;;; The code which implements the transitions is all in the miss handlers
;;; for each kind of dfun.  Those appear here.
;;;
;;; Note that within the states that cache, there are dfun updates which
;;; simply select a new cache or cache field.  Those are not considered
;;; as state transitions.
;;;
(defun make-initial-dfun (gf)
  (if (or *lazy-dfun-compute-p* (not (compute-applicable-methods-emf-std-p gf)))
      #'(lambda (&rest args)
      #+Genera (declare (dbg:invisible-frame :pcl-internals))
      (initial-dfun args gf))
      (make-final-dfun gf (precompute-effective-methods gf t))))

(defun initial-dfun (args generic-function)
  #+Genera (declare (dbg:invisible-frame :pcl-internals))
  (dfun-miss (generic-function args wrappers invalidp nfunction ntype nindex)
    (cond (invalidp)
      ((and ntype nindex)
       (dfun-update generic-function
            #'make-one-class-accessor-dfun ntype wrappers nindex))
      (t
       (dfun-update generic-function #'make-checking-dfun
            ;; nfunction is suitable only for caching, have to do this:
            (multiple-value-bind (w i function)
                (cache-miss-values generic-function args 'checking)
              (declare (ignore w i))
              function))))))

(defun make-final-dfun (gf &optional classes-list)
  (multiple-value-bind (dfun cache info)
      (make-final-dfun-internal gf classes-list)
    (set-dfun gf dfun cache info)))

(defun make-final-dfun-internal (gf &optional classes-list)
  (let ((methods (generic-function-methods gf)) type
    (new-class *new-class*) (*new-class* nil))
    (cond ((null methods)
       (values
        #'(lambda (&rest args)
        (apply #'no-applicable-method gf args))
        nil
        (no-methods-dfun-info)))
      ((setq type (cond ((every #'standard-reader-method-p methods)
                 'reader)
                ((every #'standard-writer-method-p methods)
                 'writer)))
       (with-eq-hash-table (table)
         (multiple-value-bind (table all-index first second size no-class-slots-p)
         (make-accessor-table gf type table)
               (declare (type boolean no-class-slots-p))
           (if table
           (cond ((= (the index size) 1)
              (let ((w (class-wrapper first)))
                (make-one-class-accessor-dfun gf type w all-index)))
             ((and (= (the index size) 2)
                               (or (integerp all-index) (consp all-index)))
              (let ((w0 (class-wrapper first))
                (w1 (class-wrapper second)))
                (make-two-class-accessor-dfun gf type w0 w1 all-index)))
             ((or (integerp all-index) (consp all-index))
              (make-final-one-index-accessor-dfun
               gf type all-index table))
             (no-class-slots-p
              (make-final-n-n-accessor-dfun gf type table))
             (t
              (make-final-caching-dfun gf classes-list new-class)))
           (make-final-caching-dfun gf classes-list new-class)))))
      ((use-constant-value-dfun-p gf)
       (make-final-constant-value-dfun gf classes-list new-class))
      ((use-dispatch-dfun-p gf)
       (make-final-dispatch-dfun gf))
      ((let ((specls (method-specializers (car methods))))
         (and (every #'(lambda (method)
                 (and (equal specls (method-specializers method))))
             methods)
          (not (use-caching-dfun-p gf))))
       (let ((function (get-secondary-dispatch-function gf methods nil)))
         (make-final-checking-dfun gf function classes-list new-class)))
      (t
       (make-final-caching-dfun gf classes-list new-class)))))

(defun accessor-miss (gf new object dfun-info)
  (let* ((ostate (type-of dfun-info))
     (otype (dfun-info-accessor-type dfun-info))
     oindex ow0 ow1 cache
     (args (ecase otype            ;The congruence rules assure
        (reader (list object))        ;us that this is safe despite
        (writer (list new object)))))    ;not knowing the new type yet.
    (dfun-miss (gf args wrappers invalidp nfunction ntype nindex)
      ;;
      ;; The following lexical functions change the state of the
      ;; dfun to that which is their name.  They accept arguments
      ;; which are the parameters of the new state, and get other
      ;; information from the lexical variables bound above.
      ;;
      (flet ((two-class (index w0 w1)
           (when (zerop (the index (random 2))) (psetf w0 w1 w1 w0))
           (dfun-update gf #'make-two-class-accessor-dfun ntype w0 w1 index))
         (one-index (index &optional cache)
           (dfun-update gf #'make-one-index-accessor-dfun ntype index cache))
         (n-n (&optional cache)
           (if (consp nindex)
           (dfun-update gf #'make-checking-dfun nfunction)
           (dfun-update gf #'make-n-n-accessor-dfun ntype cache)))
         (caching () ; because cached accessor emfs are much faster for accessors
           (dfun-update gf #'make-caching-dfun))
         ;;
         (do-fill (update-fn)
           (let ((ncache (fill-cache cache wrappers nindex)))
         (unless (eq ncache cache)
           (funcall-function update-fn ncache)))))
    (cond ((null ntype)
           (caching))
          ((or invalidp
           (null nindex)))
          ((not (or (std-instance-p object)
            (fsc-instance-p object)
                        #+pcl-user-instances
                        (user-instance-p object)))
           (caching))
          ((or (neq ntype otype) (listp wrappers))
           (caching))
          (t
           (ecase ostate
         (one-class
          (setq oindex (dfun-info-index dfun-info))
          (setq ow0 (dfun-info-wrapper0 dfun-info))
          (unless (eq ow0 wrappers)
            (if (eql nindex oindex)
            (two-class nindex ow0 wrappers)
            (n-n))))
         (two-class
          (setq oindex (dfun-info-index dfun-info))
          (setq ow0 (dfun-info-wrapper0 dfun-info))
          (setq ow1 (dfun-info-wrapper1 dfun-info))
          (unless (or (eq ow0 wrappers) (eq ow1 wrappers))
            (if (eql nindex oindex)
            (one-index nindex)
            (n-n))))
         (one-index
          (setq oindex (dfun-info-index dfun-info))
          (setq cache (dfun-info-cache dfun-info))
          (if (eql nindex oindex)
              (do-fill #'(lambda (ncache)
                   (one-index nindex ncache)))
              (n-n)))
         (n-n
          (setq cache (dfun-info-cache dfun-info))
          (if (consp nindex)
              (caching)
              (do-fill #'n-n))))))))))

(defun checking-miss (generic-function args dfun-info)
  (let ((ofunction (dfun-info-function dfun-info))
    (cache (dfun-info-cache dfun-info)))
    (dfun-miss (generic-function args wrappers invalidp nfunction)
      (cond (invalidp)
        ((eq ofunction nfunction)
         (let ((ncache (fill-cache cache wrappers nil)))
           (unless (eq ncache cache)
         (dfun-update generic-function #'make-checking-dfun
                  nfunction ncache))))
        (t
         (dfun-update generic-function #'make-caching-dfun))))))

(defun caching-miss (generic-function args dfun-info)
  (let ((ocache (dfun-info-cache dfun-info)))
    (dfun-miss (generic-function args wrappers invalidp function nil nil t)
      (cond (invalidp)
        (t
         (let ((ncache (fill-cache ocache wrappers function)))
           (unless (eq ncache ocache)
         (dfun-update generic-function
                  #'make-caching-dfun ncache))))))))

(defun constant-value-miss (generic-function args dfun-info)
  (let ((ocache (dfun-info-cache dfun-info)))
    (dfun-miss (generic-function args wrappers invalidp function nil nil t)
      (cond (invalidp)
        (t
         (let* ((value (method-constant-value (method-function-method function)))
            (ncache (fill-cache ocache wrappers value)))
           (unless (eq ncache ocache)
         (dfun-update generic-function
                  #'make-constant-value-dfun ncache))))))))



(defvar dfun-count nil)
(defvar dfun-list nil)
(defvar *minimum-cache-size-to-list*)

(defun list-dfun (gf)
  (let* ((sym (type-of (gf-dfun-info gf)))
     (a (assq sym dfun-list)))
    (unless a
      (push (setq a (list sym)) dfun-list))
    (push (generic-function-name gf) (cdr a))))

(defun list-all-dfuns ()
  (setq dfun-list nil)
  (map-all-generic-functions #'list-dfun)
  dfun-list)

(defun list-large-cache (gf)
  (let* ((sym (type-of (gf-dfun-info gf)))
     (cache (gf-dfun-cache gf)))
    (when cache
      (let ((size (cache-size cache)))
        (declare (type index size))
    (when (>= size (the index *minimum-cache-size-to-list*))
      (let ((a (assoc size dfun-list)))
        (unless a
          (push (setq a (list size)) dfun-list))
        (push (let ((name (generic-function-name gf)))
            (if (eq sym 'caching) name (list name sym)))
          (cdr a))))))))

(defun list-large-caches (&optional (*minimum-cache-size-to-list* 130))
  (setq dfun-list nil)
  (map-all-generic-functions #'list-large-cache)
  (setq dfun-list (sort dfun-list #'< :key #'car))
  (mapc #'print dfun-list)
  (values))


(defun count-dfun (gf)
  (let* ((sym (type-of (gf-dfun-info gf)))
     (cache (gf-dfun-cache gf))
     (a (assq sym dfun-count)))
    (unless a
      (push (setq a (list sym 0 nil)) dfun-count))
    (setf (cadr a) (the index (1+ (the index (cadr a)))))
    (when cache
      (let* ((size (cache-size cache))
         (b (assoc size (third a))))
    (unless b
      (push (setq b (cons size 0)) (third a)))
        (setf (cdr b) (the index (1+ (the index (cdr b)))))))))

(defun count-all-dfuns ()
  (setq dfun-count (mapcar #'(lambda (type) (list type 0 nil))
               '(ONE-CLASS TWO-CLASS DEFAULT-METHOD-ONLY
                 ONE-INDEX N-N CHECKING CACHING
                 DISPATCH)))
  (map-all-generic-functions #'count-dfun)
  (mapc #'(lambda (type+count+sizes)
        (setf (third type+count+sizes)
          (sort (third type+count+sizes) #'< :key #'car)))
    dfun-count)
  (mapc #'(lambda (type+count+sizes)
        (format t "~&There are ~4d dfuns of type ~s"
            (cadr type+count+sizes) (car type+count+sizes))
        (format t "~%   ~S~%" (caddr type+count+sizes)))
    dfun-count)
  (values))

(defun gfs-of-type (type)
  (unless (consp type) (setq type (list type)))
  (let ((gf-list nil))
    (map-all-generic-functions #'(lambda (gf)
                   (when (memq (type-of (gf-dfun-info gf)) type)
                     (push gf gf-list))))
    gf-list))